home *** CD-ROM | disk | FTP | other *** search
/ X User Tools / X User Tools (O'Reilly and Associates)(1994).ISO / sun4c / archive / tcltk.z / tcltk / slib / tk / menu.tcl < prev    next >
Text File  |  1994-09-20  |  11KB  |  353 lines
  1. # menu.tcl --
  2. #
  3. # This file contains Tcl procedures used to manage Tk menus and
  4. # menubuttons.  Most of the code here is dedicated to support for
  5. # pulling down menus and menu traversal via the keyboard.
  6. #
  7. # $Header: /user6/ouster/wish/library/RCS/menu.tcl,v 1.23 93/09/17 14:02:28 ouster Exp $ SPRITE (Berkeley)
  8. #
  9. # Copyright (c) 1992-1993 The Regents of the University of California.
  10. # All rights reserved.
  11. #
  12. # Permission is hereby granted, without written agreement and without
  13. # license or royalty fees, to use, copy, modify, and distribute this
  14. # software and its documentation for any purpose, provided that the
  15. # above copyright notice and the following two paragraphs appear in
  16. # all copies of this software.
  17. #
  18. # IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  19. # DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  20. # OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  21. # CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  22. #
  23. # THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  24. # INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  25. # AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  26. # ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  27. # PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  28. #
  29.  
  30. # The procedure below is publically available.  It is used to identify
  31. # a frame that serves as a menu bar and the menu buttons that lie inside
  32. # the menu bar.  This procedure establishes proper "menu bar" behavior
  33. # for all of the menu buttons, including keyboard menu traversal.  Only
  34. # one menu bar may exist for a given top-level window at a time.
  35. # Arguments:
  36. #    
  37. # bar -                The path name of the containing frame.  Must
  38. #                be an ancestor of all of the menu buttons,
  39. #                since it will be be used in grabs.
  40. # additional arguments -    One or more menu buttons that are descendants
  41. #                of bar.  The order of these arguments
  42. #                determines the order of keyboard traversal.
  43. #                If no extra arguments are named then all of
  44. #                the menu bar information for bar is cancelled.
  45.  
  46. proc tk_menuBar {w args} {
  47.     global tk_priv
  48.     if {$args == ""} {
  49.     if [catch {set menus $tk_priv(menusFor$w)}] {
  50.         return ""
  51.     }
  52.     return $menus
  53.     }
  54.     if [info exists tk_priv(menusFor$w)] {
  55.     unset tk_priv(menusFor$w)
  56.     unset tk_priv(menuBarFor[winfo toplevel $w])
  57.     }
  58.     if {$args == "{}"} {
  59.     return
  60.     }
  61.     set tk_priv(menusFor$w) $args
  62.     set tk_priv(menuBarFor[winfo toplevel $w]) $w
  63.     bind $w <Any-Alt-KeyPress> {tk_traverseToMenu %W %A}
  64.     bind $w <F10> {tk_firstMenu %W}
  65.     bind $w <Any-ButtonRelease-1> tk_mbUnpost
  66. }
  67.  
  68. proc tk_menus {w args} {
  69.     error "tk_menus is obsolete in Tk versions 3.0 and later; please change your scripts to use tk_menuBar instead"
  70. }
  71.  
  72. # The procedure below is publically available.  It takes any number of
  73. # arguments that are names of widgets or classes.  It sets up bindings
  74. # for the widgets or classes so that keyboard menu traversal is possible
  75. # when the input focus is in those widgets or classes.
  76.  
  77. proc tk_bindForTraversal args {
  78.     foreach w $args {
  79.     bind $w <Any-Alt-KeyPress> {tk_traverseToMenu %W %A}
  80.     bind $w <F10> {tk_firstMenu %W}
  81.     }
  82. }
  83.  
  84. # The procedure below does all of the work of posting a menu (including
  85. # unposting any other menu that might currently be posted).  The "w"
  86. # argument is the name of the menubutton for the menu to be posted.
  87. # Note:  if $w is disabled then the procedure does nothing.
  88.  
  89. proc tk_mbPost {w} {
  90.     global tk_priv tk_strictMotif
  91.     if {[lindex [$w config -state] 4] == "disabled"} {
  92.     return
  93.     }
  94.     if {$w == $tk_priv(posted)} {
  95.     grab -global $tk_priv(grab)
  96.     return
  97.     }
  98.     set menu [lindex [$w config -menu] 4]
  99.     if {$menu == ""} {
  100.     return
  101.     }
  102.     if ![string match $w* $menu] {
  103.     error "can't post $menu:  it isn't a descendant of $w (this is a new requirement in Tk versions 3.0 and later)"
  104.     }
  105.     set cur $tk_priv(posted)
  106.     if {$cur != ""} tk_mbUnpost
  107.     set tk_priv(relief) [lindex [$w config -relief] 4]
  108.     $w config -relief raised
  109.     set tk_priv(posted) $w
  110.     if {$tk_priv(focus) == ""} {
  111.     set tk_priv(focus) [focus]
  112.     }
  113.     set tk_priv(activeBg) [lindex [$menu config -activebackground] 4]
  114.     set tk_priv(activeFg) [lindex [$menu config -activeforeground] 4]
  115.     if $tk_strictMotif {
  116.     $menu config -activebackground [lindex [$menu config -background] 4]
  117.     $menu config -activeforeground [lindex [$menu config -foreground] 4]
  118.     }
  119.     $menu activate none
  120.     focus $menu
  121.     $menu post [winfo rootx $w] [expr [winfo rooty $w]+[winfo height $w]]
  122.     if [catch {set grab $tk_priv(menuBarFor[winfo toplevel $w])}] {
  123.     set grab $w
  124.     } else {
  125.     if [lsearch $tk_priv(menusFor$grab) $w]<0 {
  126.         set grab $w
  127.     }
  128.     }
  129.     set tk_priv(cursor) [lindex [$grab config -cursor] 4]
  130.     $grab config -cursor arrow
  131.     set tk_priv(grab) $grab
  132.     grab -global $grab
  133. }
  134.  
  135. # The procedure below does all the work of unposting the menubutton that's
  136. # currently posted.  It takes no arguments.  Special notes:
  137. # 1. It's important to unpost the menu before releasing the grab, so
  138. #    that any Enter-Leave events (e.g. from menu back to main
  139. #    application) have mode NotifyGrab.
  140. # 2. Be sure to enclose various groups of commands in "catch" so that
  141. #    the procedure will complete even if the menubutton or the menu
  142. #    or the grab window has been deleted.
  143.  
  144. proc tk_mbUnpost {} {
  145.     global tk_priv
  146.     set w $tk_priv(posted)
  147.     if {$w != ""} {
  148.     catch {
  149.         set menu [lindex [$w config -menu] 4]
  150.         $menu unpost
  151.         $menu config -activebackground $tk_priv(activeBg)
  152.         $menu config -activeforeground $tk_priv(activeFg)
  153.         $w config -relief $tk_priv(relief)
  154.     }
  155.     catch {$tk_priv(grab) config -cursor $tk_priv(cursor)}
  156.     catch {focus $tk_priv(focus)}
  157.     grab release $tk_priv(grab)
  158.     set tk_priv(grab) ""
  159.     set tk_priv(focus) ""
  160.     set tk_priv(posted) {}
  161.     }
  162. }
  163.  
  164. # The procedure below is invoked to implement keyboard traversal to
  165. # a menu button.  It takes two arguments:  the name of a window where
  166. # a keystroke originated, and the ascii character that was typed.
  167. # This procedure finds a menu bar by looking upward for a top-level
  168. # window, then looking for a window underneath that named "menu".
  169. # Then it searches through all the subwindows of "menu" for a menubutton
  170. # with an underlined character matching char.  If one is found, it
  171. # posts that menu.
  172.  
  173. proc tk_traverseToMenu {w char} {
  174.     global tk_priv
  175.     if {$char == ""} {
  176.     return
  177.     }
  178.     set char [string tolower $char]
  179.  
  180.     foreach mb [tk_getMenuButtons $w] {
  181.     if {[winfo class $mb] == "Menubutton"} {
  182.         set char2 [string index [lindex [$mb config -text] 4] \
  183.             [lindex [$mb config -underline] 4]]
  184.         if {[string compare $char [string tolower $char2]] == 0} {
  185.         tk_mbPost $mb
  186.         [lindex [$mb config -menu] 4] activate 0
  187.         return
  188.         }
  189.     }
  190.     }
  191. }
  192.  
  193. # The procedure below is used to implement keyboard traversal within
  194. # the posted menu.  It takes two arguments:  the name of the menu to
  195. # be traversed within, and an ASCII character.  It searches for an
  196. # entry in the menu that has that character underlined.  If such an
  197. # entry is found, it is invoked and the menu is unposted.
  198.  
  199. proc tk_traverseWithinMenu {w char} {
  200.     if {$char == ""} {
  201.     return
  202.     }
  203.     set char [string tolower $char]
  204.     set last [$w index last]
  205.     if {$last == "none"} {
  206.     return
  207.     }
  208.     for {set i 0} {$i <= $last} {incr i} {
  209.     if [catch {set char2 [string index \
  210.         [lindex [$w entryconfig $i -label] 4] \
  211.         [lindex [$w entryconfig $i -underline] 4]]}] {
  212.         continue
  213.     }
  214.     if {[string compare $char [string tolower $char2]] == 0} {
  215.         tk_mbUnpost
  216.         $w invoke $i
  217.         return
  218.     }
  219.     }
  220. }
  221.  
  222. # The procedure below takes a single argument, which is the name of
  223. # a window.  It returns a list containing path names for all of the
  224. # menu buttons associated with that window's top-level window, or an
  225. # empty list if there are none.
  226.  
  227. proc tk_getMenuButtons w {
  228.     global tk_priv
  229.     set top [winfo toplevel $w]
  230.     if [catch {set bar [set tk_priv(menuBarFor$top)]}] {
  231.     return ""
  232.     }
  233.     return $tk_priv(menusFor$bar)
  234. }
  235.  
  236. # The procedure below is used to traverse to the next or previous
  237. # menu in a menu bar.  It takes one argument, which is a count of
  238. # how many menu buttons forward or backward (if negative) to move.
  239. # If there is no posted menu then this procedure has no effect.
  240.  
  241. proc tk_nextMenu count {
  242.     global tk_priv
  243.     if {$tk_priv(posted) == ""} {
  244.     return
  245.     }
  246.     set buttons [tk_getMenuButtons $tk_priv(posted)]
  247.     set length [llength $buttons]
  248.     for {set i 0} 1 {incr i} {
  249.     if {$i >= $length} {
  250.         return
  251.     }
  252.     if {[lindex $buttons $i] == $tk_priv(posted)} {
  253.         break
  254.     }
  255.     }
  256.     incr i $count
  257.     while 1 {
  258.     while {$i < 0} {
  259.         incr i $length
  260.     }
  261.     while {$i >= $length} {
  262.         incr i -$length
  263.     }
  264.     set mb [lindex $buttons $i]
  265.     if {[lindex [$mb configure -state] 4] != "disabled"} {
  266.         break
  267.     }
  268.     incr i $count
  269.     }
  270.     tk_mbUnpost
  271.     tk_mbPost $mb
  272.     [lindex [$mb config -menu] 4] activate 0
  273. }
  274.  
  275. # The procedure below is used to traverse to the next or previous entry
  276. # in the posted menu.  It takes one argument, which is 1 to go to the
  277. # next entry or -1 to go to the previous entry.  Disabled entries are
  278. # skipped in this process.
  279.  
  280. proc tk_nextMenuEntry count {
  281.     global tk_priv
  282.     if {$tk_priv(posted) == ""} {
  283.     return
  284.     }
  285.     set menu [lindex [$tk_priv(posted) config -menu] 4]
  286.     if {[$menu index last] == "none"} {
  287.     return
  288.     }
  289.     set length [expr [$menu index last]+1]
  290.     set i [$menu index active]
  291.     if {$i == "none"} {
  292.     set i 0
  293.     } else {
  294.     incr i $count
  295.     }
  296.     while 1 {
  297.     while {$i < 0} {
  298.         incr i $length
  299.     }
  300.     while {$i >= $length} {
  301.         incr i -$length
  302.     }
  303.     if {[catch {$menu entryconfigure $i -state} state] == 0} {
  304.         if {[lindex $state 4] != "disabled"} {
  305.         break
  306.         }
  307.     }
  308.     incr i $count
  309.     }
  310.     $menu activate $i
  311. }
  312.  
  313. # The procedure below invokes the active entry in the posted menu,
  314. # if there is one.  Otherwise it does nothing.
  315.  
  316. proc tk_invokeMenu {menu} {
  317.     set i [$menu index active]
  318.     if {$i != "none"} {
  319.     tk_mbUnpost
  320.     update idletasks
  321.     $menu invoke $i
  322.     }
  323. }
  324.  
  325. # The procedure below is invoked to keyboard-traverse to the first
  326. # menu for a given source window.  The source window is passed as
  327. # parameter.
  328.  
  329. proc tk_firstMenu w {
  330.     set mb [lindex [tk_getMenuButtons $w] 0]
  331.     if {$mb != ""} {
  332.     tk_mbPost $mb
  333.     [lindex [$mb config -menu] 4] activate 0
  334.     }
  335. }
  336.  
  337. # The procedure below is invoked when a button-1-down event is
  338. # received by a menu button.  If the mouse is in the menu button
  339. # then it posts the button's menu.  If the mouse isn't in the
  340. # button's menu, then it deactivates any active entry in the menu.
  341. # Remember, event-sharing can cause this procedure to be invoked
  342. # for two different menu buttons on the same event.
  343.  
  344. proc tk_mbButtonDown w {
  345.     global tk_priv
  346.     if {[lindex [$w config -state] 4] == "disabled"} {
  347.     return
  348.     }
  349.     if {$tk_priv(inMenuButton) == $w} {
  350.     tk_mbPost $w
  351.     }
  352. }
  353.